perm filename TR3.F4[P11,LCS] blob sn#341679 filedate 1978-03-12 generic text, type C, neo UTF8
COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	      SUBROUTINE MSCAN(LL,W)
C00017 ENDMK
C⊗;
      SUBROUTINE MSCAN(LL,W)
      DIMENSION RX(100),W(1),TONES(21)
      COMMON /TR/I(80),JX(100),NN(2),LX(12),INST(27,5),MX5(40)
     1,INSNUM(27),FQDR(5/32,27),P(30),NPAR(27),JSEM,IPRNT,IPP
     1,SRATE,RNCHN,RMAG,INUM,INS,MM,M,N,JJ,X,Y,IK
     1,ENDX,J  /KNAM/KNAM,IPLAY,JFLNM,IOPEN
      COMMON /SBFILN/SBFILN /AR/IOP /IGEN/IGEN /JP/JPRNT,JWRT
C   OUT, OSC, AD2, RAN, ENV, STR, AD3, AD4, MLT, SET, RAH, GEN
      INTEGER FQDR,RPR
      EQUIVALENCE (IZR,RZR),(LESS,LX(9)),(RX,JX),
     1 (INN,RNN),(RX2,RX(3)),(P2,P(2)),(RX3,RX(5)),(I3,I(3))
     1 ,(ISEMI,LX(2)),(IAST,LX(3))
     1,(LPR,LX(11)),(RPR,LX(12)),(ICOM,LX(10)),(LAROW,LX(7))
      DATA TONES/246.945,261.62,277.18,277.8,293.66,311.13,311.13,
     1 329.63,349.23,329.63,349.23,369.99,369.99,
     1 391.99,415.31,415.31,440.0,466.16,466.16,493.89,523.24/
CCC   DATA M5/'OUT','OSC','AD2','RAN','ENV','STR','AD3',
CCC  1'AD4','MLT','SET','RAH','END'/

C**** CODE NUMS. 1=OUT 2=OSC 3=AD2 4=RAN 5=END 6=STR 7=AD3 8=AD4 9=MLT
C**** 10=SET 11=RAH 12=END 13=INS  B1=101 ETC.  P1=201 ETC.  F1=301 ETC.
C**** 400=PLAY 401=FINI 402=SRATE 403=NCHNS 404=PRINT 405=CHA 406=POWER
C**** 407=SRT 409=GEN 410=DUR 411=FREQ 412=INSTRUMENT 413=UNIT GEN.
C**** 500=CF 501=C 502=CS 503=DF 504=D 505=DS 506=EF 507=E 508=ES 509=FF
C**** 510=F 511=FS 512=GF 513=G 514=GS 515=AF 516=A 517=AS 518=BF 519=B 520=BS

30      IF(JSEM.NE.0)GO TO 34
      LL=1
      INS=-1
34      J=J+2      
      IPP=0             
C!FOR 'P3←333;' ETC.
      IPOW=0
      IOP=-1
      IXJ=JX(J)      
      IF(IXJ.NE.ISEMI)GO TO 9
10      IF(IGEN.GT.100)W(3)=IGEN
15      JSEM=-1
      RETURN
9      IF(J.GE.MM)GO TO 1001  
      IF(RX(J+1).EQ.-9999.0)GO TO 11  
C!*** SKIP IF NUMBER
      IF(IGEN.GT.0)GO TO 450

CC    DO 32 K=1,11      
C!***** LOOK FOR SPECIAL WORDS
CC32      IF(IWD(K).EQ.IXJ)
CC   1 GO TO (3,13,13,304,303,302,303,4,505,505,422)K
	IF(IXJ/400.NE.1)GO TO 32
	K=IXJ-399
       GO TO (3,13,304,303,302,303,4,505,505,422)K
32    IF(IXJ.NE.13)GO TO 402
CCC   IF(IXJ.NE.'INS')GO TO 402
      KNAM=IXJ
      W(1)=2
      IGEN=2
      GO TO 424
505      JK=4         
C !**** FOR SRATE OR SRT
      IF(K.NE.4)JK=2      
      JK=J+JK
      GO TO 304

CC450      DO 400 K=1,12
CC400      IF(IXJ.EQ.M5(K))GO TO(425,425,425,425,425,425,425,425
CC     1,425,425,425,411),K
450	K=IXJ
C** HERE FOR INST DEFINITIONS.
	IF(K.LE.13.AND.K.GT.0)GO TO(425,425,425,425,425
	1,425,425,425,425,425,425,411),K
      DO 451 JK=1,40,2   
C!*** FOR USER-ADDED UNIT GENS. (UP TO 20)
      IF(MX5(JK).NE.IXJ)GO TO 451
      W(3)=MX5(JK+1)
      GO TO 426
451      CONTINUE
503      TYPE 504,IXJ
      JSEM=0
      J=MM
      RETURN   
504      FORMAT(' UNKNOWN SYMBOL ',A5)
411       LL=3
      KNAM=IXJ
      IGEN=1   
C!*** =1 IS FLAG TO CHANGE IT TO -1
      J=MM
      INS=-1
      GO TO 10  
422      W(1)=3   
C!***** GEN
      KNAM=IXJ
      IGEN=0
424      INS=-1
      LL=2
      GO TO 36
425      W(3)=K+100
426      KNAM=IXJ
436      LL=4  
      GO TO 36

3      J=J+2      
C   !**** FOUND 'PLAY;'
      IF(JX(J).NE.ISEMI)CALL ERR(1)
      IPLAY=-1
CCC   SBFILN='TEST'
CCC   CALL PUTFIL(SBFILN)
CCC   CALL FASTOU(I,128)
C THE HEADER (SUCH AS IT IS)  USETO IN MAIN PROG.
      JSEM=-1
      IF(J.LT.MM)GO TO 34
      JSEM=0
      RETURN
4      JL=LL
      JOP=IOP
      J=J+2
      IF(JX(J).NE.LPR)CALL ERR(2)
      IPOW=-1
      IOP=-1
      GO TO 36  
C!**FIND NUM UP TO THE COMMA
7      IF(IPOW.GT.0)GO TO 8
      IPOW=1
      GO TO 36
8      LL=LL-2
       W(LL)=W(LL)**W(LL+1)
      IPOW=0
      IOP=JOP       
C!** GET BACK FLAGS
      GO TO 38
      
302      LL=1
      IPRNT=-1    
C!***** FOR 'PRINT' FEATURE
      GO TO 36
304      SRATE=RX(J+4)
      J=J+6
      RMAG=512./SRATE
      W(3)=4
      W(4)=SRATE
351      W(1)=11
      W(2)=0
      IGEN=0
      LL=5
      GO TO 15
303      IF(IXJ.EQ.'CHA')J=J-2
      RNCHN=RX(J+4)    
C!**** FOR NCHNS←N;
      J=J+6
CC      IF(RX(JK+1).NE.-9999.0)JK=JK+2  
C!*** SKIP A COMMA
CC      IF(JX(JK+2).EQ.ISEMI)GO TO 352  
C!*** FOR NCHNS←n;
352      W(3)=8            
C!*** FOR NCHNS
      W(4)=RNCHN-1
      GO TO 351
35      IF(IPLAY.GE.0)CALL ERR(4)
      W(2)=INSNUM(IK)      
C!**** W IS P ARRAY IN MUSIC5
      LL=3      
C!**** W(2) AND W(3) WILL BE EXCHANGED LATER
      KNAM=IXJ
36      J=J+2      
      IF(J.GT.MM)GO TO 1001        
C!******  50 = DONE
CC      JK=J*2
      IXJ=JX(J)      
      IF(IXJ.NE.ISEMI)GO TO 1
      JSEM=-1
1000      IF(IPP.EQ.0)GO TO 10
      P(IPP)=W(1)
      LL=1
      IPP=0
      IF(J.LT.MM)GO TO 30  
      INS=-1   
C!*** I HOPE THIS IS THE RIGHT PLACE FOR THIS.
1001      IF(IGEN.EQ.0.OR.JSEM.EQ.0)JSEM=1
      IF(JSEM)JSEM=0
      RETURN

1      IF(RX(J+1).NE.-9999.0)GO TO 2
11      IF(IOP)GO TO 40
      IF(IOP.NE.5)GO TO 12
      RX(J)=-RX(J)  
C!*** IOP=5 MEANS MINUS WITH COMMA IN FRONT
      W(LL)=RX(J)
      LL=LL+1
      GO TO 14
12      CALL ARITH(RX(J),W,LL)
14      IOP=-1    
C!*** RESET OPERATOR FLAG
      GO TO 36   
C!*** USE PARENTH'S FOR COMPOSITE EXPRESSIONS!!!!

40      W(LL)=RX(J)
38      LL=LL+1
      IF(IOP)GO TO 36
C IOP = NEG = NO OPERATOR BEFORE THIS ITEM.
      LL=LL-1
380      CALL ARITH(W(LL),W,LL)
      GO TO 14

402      IF(JSEM.GT.0)GO TO 2      
C!**** READING CONTINUATION LINE.
	IF(IXJ.GE.0)GO TO 33
C NEXT TRIES TO FIND INST. NAME.
	NA=-1-IXJ
	M=JX(J+1)
C NA POINTS TO SPOT IN I ARRAY, M IS WDCNT.
	DO 133 IK=1,INUM
	DO 233 II=1,M
233	IF(INST(IK,II).NE.I(II+NA))GO TO 133
C NOW WE FOUND AN INST. NAME.
C******* INST NAMES CANNOT HAVE SAME STRING OF 1ST LETTERS AS OTHER THINGS.
333	IF(M.EQ.5)GO TO 35
	M=M+1
	IF(INST(IK,M).EQ.0)GO TO 333
133	CONTINUE
CC    DO 33 IK=1,INUM
CC33      IF(IXJ.EQ.INST(IK))GO TO 35
33    INS=2      
C! NEXT IS SOMETHING OUTSIDE OF INST. AND PARAMS.

2      IF(IGEN.GT.0)GO TO 427
CCC   DO 306 K=1,21
CCC   IF(IXJ.NE.ISCL(K))GO TO 306
	IF(IXJ.GT.520)GO TO 341
	IF(IXJ.LT.500)GO TO 427
C NOW FOUND A NOTE
	K=IXJ-499
      W(LL)=TONES(K)
CC      JK=K
CC      CALL NOTES(JK,W(LL))
      GO TO 38
CCC306      CONTINUE  
C!***** FINDS NOTE IN SCALE

CC427      DO 307 K=1,40        
C!****** FIND A PARAM NUM.
CC    IF(IXJ.NE.IPARS(K))GO TO 307
427	IF(IXJ.GE.300)GO TO 307
	IF(IXJ.LT.200)GO TO 344
	K=IXJ-200
C NOW K HAS PARAM NUM.
      IF(INS.LE.0)GO TO 340
      JK=J+2      
      IF(JX(JK).NE.LAROW)GO TO 340
      IPP=K
      LL=1
      J=JK      
      GO TO 36
340      W(LL)=P(K)      
C!***** FOUND Pn
      IF(IPRNT)GO TO 38
      IF(IGEN.GT.0)W(LL)=K+2.  
C!*** PARAM NUMS ARE 2 LESS THAN IN BOOK.
      GO TO 38    
C!**** P4 IS CHANGED TO 6
307    IF(IXJ.GE.400)GO TO 344

CC    DO 344 K=1,30
CC    IF(IXJ.NE.IFUN(K))GO TO 344
	IF(IXJ/300.NE.1)GO TO 344
CCC   JL=K
	JL=IXJ-300
      IF(IGEN.GT.0)JL=-JL-100      
C!*** FOR Fn IN INST DEFINITION
      W(LL)=JL
      GO TO 38
344      CONTINUE

      IF(IGEN.LE.0)GO TO 341
CC    DO 342 K=1,20
CC    IF(IXJ.NE.IB(K))GO TO 342
C*** FOR B1, ETC. IN INST. DEFS.
	IF(IXJ/100.NE.1)GO TO 341
	 W(LL)=100-IXJ
CCC   W(LL)=-K
      GO TO 38
342      CONTINUE

341      DO 39 K=3,6
      IF(LX(K).NE.IXJ)GO TO 39
      IOP=K-2
      JK=JX(J-2)
      IF(JK.EQ.ICOM)IOP=5 
C!** COMMA DISABLES NEXT OPERATOR
      IF(JK.EQ.LAROW)IOP=5 
C!**  ← DISABLES NEXT OPERATOR
      IF(JK.EQ.LPR)IOP=5 
C!** LFT PARENTH. DISABLES NEXT OPERATOR
      GO TO 36
39      CONTINUE
308      IF(IXJ.EQ.LAROW)GO TO 36   
C!*** PASS LEFT ARROW
C**** OR SHOULD NEXT BE 406???
      IF(IXJ.EQ.406)GO TO 4
CC    IF(IXJ.EQ.IPWR)GO TO 4
      IF(IXJ.EQ.RPR)GO TO 500
      IF(IXJ.EQ.LPR)GO TO 500
C**** OR SHOULD NEXT BE 402???
      IF(IXJ.NE.402)GO TO 510
CC    IF(IXJ.NE.JSRT.AND.IXJ.NE.ISRT)GO TO 510
      W(LL)=SRATE
335      LL=LL+1
      GO TO 36
C**** OR SHOULD NEXT BE 403???
510      IF(IXJ.NE.403)GO TO 511
CC510      IF(IXJ.NE.NCHNS)GO TO 511
      W(LL)=RNCHN
      GO TO 335
511      IF(IXJ.NE.ICOM)GO TO 503       
C!***** UNKNOWN CHAR.
500      IF(IPOW.NE.0)GO TO 7
      IF(IXJ.NE.LPR)GO TO 501
      JPOW=IPOW
      IPOW=0
      KOP=IOP
      IOP=-1
      JL=LL      
C!**** SAVE VARIOUS POINTERS WHEN INSIDE PARENTHS.
      GO TO 36
501      IF(IXJ.NE.RPR)GO TO 502
      IPOW=JPOW      
C!*** GET BACK STUFF
      IOP=KOP
CC      LL=JL+1      !**?????
      IF(IOP)GO TO 36
      LL=JL
      GO TO 380      
C!GO DO ARITHMETIC
502      IF(IPRNT)GO TO 36     
C!**** FOUND COMMA IN PRINT STATEMENT.
5      IF(JX(J-2).NE.ICOM)GO TO 132
433      W(LL)=P(LL-2)   
C!** ONLY CARES ABOUT 2 COMMAS IN A ROW
      GO TO 335
132      IF(INS.GE.0)GO TO 36
      IF(LL.EQ.3)GO TO 433      
C!*** =3 MEANS COMMA FOR P1.
      GO TO 36

13      LL=2
      IPLAY=0            
C!*** TURN OFF PLAY FLAG
      W(1)=6
      W(2)=ENDX+.5   
C!***** ENDX IS P1+P2 OF THE LONGEST LASTING INST.
      IF(JPRNT)TYPE 51,LL,W(1),W(2)
      IF(JWRT.GE.0)GO TO 130
      WRITE(21)LL,W(1),W(2)
      END FILE 21
	IOPEN=-1
      TYPE 131,JFLNM
130      J=MM
      JSEM=99    
C!*** WON'T READ LINE BEYOND 'FINISH;'  ***************
      ENDX=-1
51      FORMAT(I3,35F10.3)
131      FORMAT(9X,A5,'.DAT WAS WRITTEN  *****')
      END